library(tidyquant)
library(tidyverse)
library(tsibble)
library(fable)
library(feasts)

Data

data = tq_get(c("AMZN", "DIS"), get = "stock.prices", from = "2023-01-01", to = "2024-03-29") %>% select(symbol, date, adjusted)
data
data = data %>% group_by(symbol) %>% mutate(t = row_number())
data
data = as_tsibble(data, index = t, key = symbol)

Model spec

fit = data %>% model(stl = STL(adjusted))
fit |>
  components() |>
  autoplot()

filter(fit, symbol == "DIS") %>% gg_tsresiduals()

filter(fit, symbol == "DIS") %>%
  generate(new_data = data, times = 10,
           bootstrap_block_size = 8) |>
  autoplot(.sim) +
  autolayer(filter(data, symbol=="DIS"), adjusted, colour = "black") +
  guides(colour = "none") +
  labs(title = "Stock prices: Bootstrapped series",
       y="price")
Warning: no non-missing arguments to max; returning -Inf

filter(fit, symbol == "AMZN") %>%
  generate(new_data = data, times = 10,
           bootstrap_block_size = 100) |>
  autoplot(.sim) +
  autolayer(filter(data, symbol=="AMZN"), adjusted, colour = "black") +
  guides(colour = "none") +
  labs(title = "Stock prices: Bootstrapped series",
       y="price")
Warning: no non-missing arguments to max; returning -Inf

Simulación

sim <- fit |>
  generate(new_data = data, times = 100,
           bootstrap_block_size = 50) %>%
  select(-.model, -adjusted)
Warning: no non-missing arguments to max; returning -InfWarning: no non-missing arguments to max; returning -Inf
sim
arima_forecasts <- sim |>
  model(arima = ARIMA(.sim)) |>
  forecast(h = 20)
Warning: NaNs producedWarning: NaNs producedWarning: NaNs producedWarning: NaNs producedWarning: NaNs produced
arima_forecasts |> filter(symbol=="DIS") %>%
  as_tsibble(key = c(".rep", "symbol"), index = t) %>%
  autoplot(.mean) +
  autolayer(filter(data, symbol=="DIS"), adjusted, colour = "black") +
  guides(colour = "none") +
  labs(title = "Stock prices: Bootstrapped series",y="price", x = "period")

bagged <- ets_forecasts |>  group_by(symbol) %>%
  summarise(bagged_mean = mean(.mean))

data |> filter(symbol=="AMZN") %>%
  autoplot() +
  autolayer(filter(bagged, symbol=="AMZN")) +
  labs(title = "Stock prices: Bootstrapped series",y="price", x = "period")
Plot variable not specified, automatically selected `.vars = adjusted`Plot variable not specified, automatically selected `.vars = bagged_mean`

Ensamble

STLF <- decomposition_model(
  STL(adjusted ~ season(window = Inf)),
  ETS(season_adjust ~ season("N"))
)

fit_ensamble = data %>% model(
                            ets = ETS(adjusted),
                            arima = ARIMA(adjusted),
                            STLF
) %>% mutate(combination = (ets + arima + STLF)/3)

fc = fit_ensamble %>% forecast(h = 20)
fit_ensamble
accuracy(fit_ensamble) %>% arrange(MAPE)
fc %>% autoplot(data, level=NULL)
`mutate_if()` ignored the following grouping variables:

ticker = "DIS"
fit_ensamble %>% filter(symbol == ticker) %>% augment() |>
  ggplot(aes(x = t)) +
  geom_line(aes(y = adjusted, colour = "reales")) +
  geom_line(aes(y = .fitted, colour = .model)) +
  labs(y = NULL,
    title = ticker
  ) +
  guides(colour = guide_legend(title = NULL))

LS0tCnRpdGxlOiAnQmFnZ2luZycKc3VidGl0bGU6ICdDbGFzZSBzZXJpZXMgZGUgdGllbXBvLCBwcmltYXZlcmEgMjAyNCcKYXV0aG9yOiAnRGFuaWVsIE51w7FvLCBkYW5pZWwubnVub0BpdGVzby5teCcKZGF0ZTogIkFicmlsIDI0LCAyMDI0IgpvdXRwdXQ6CiAgaHRtbF9ub3RlYm9vazoKICAgIHRvYzogeWVzCiAgICB0b2NfZmxvYXQ6IHllcwogICAgdGhlbWU6IGNvc21vCiAgICBoaWdobGlnaHQ6IHRhbmdvCiAgZ2l0aHViX2RvY3VtZW50OgogICAgdG9jOiB5ZXMKICAgIGRldjoganBlZwogIGh0bWxfZG9jdW1lbnQ6CiAgICB0b2M6IHllcwogICAgZGZfcHJpbnQ6IHBhZ2VkCi0tLQoKYGBge3Igc2V0dXAsIGVjaG8gPSBGQUxTRX0Ka25pdHI6Om9wdHNfY2h1bmskc2V0KGVjaG89IFRSVUUsCiAgICAgICAgICAgICAgICAgICAgICBmaWcuaGVpZ2h0ID0gNiwgZmlnLndpZHRoID0gNykKYGBgCgpgYGB7PWh0bWx9CjxzdHlsZT4KLmZvcmNlQnJlYWsgeyAtd2Via2l0LWNvbHVtbi1icmVhay1hZnRlcjogYWx3YXlzOyBicmVhay1hZnRlcjogY29sdW1uOyB9Cjwvc3R5bGU+CmBgYAohW10oaHR0cHM6Ly91cGxvYWQud2lraW1lZGlhLm9yZy93aWtpcGVkaWEvY29tbW9ucy9kL2RiL0xvZ29fSVRFU09fbm9ybWFsLmpwZykKCgpgYGB7cn0KbGlicmFyeSh0aWR5cXVhbnQpCmxpYnJhcnkodGlkeXZlcnNlKQpsaWJyYXJ5KHRzaWJibGUpCmxpYnJhcnkoZmFibGUpCmxpYnJhcnkoZmVhc3RzKQpgYGAKCiMgRGF0YQpgYGB7cn0KZGF0YSA9IHRxX2dldChjKCJBTVpOIiwgIkRJUyIpLCBnZXQgPSAic3RvY2sucHJpY2VzIiwgZnJvbSA9ICIyMDIzLTAxLTAxIiwgdG8gPSAiMjAyNC0wMy0yOSIpICU+JSBzZWxlY3Qoc3ltYm9sLCBkYXRlLCBhZGp1c3RlZCkKZGF0YQpgYGAKCmBgYHtyfQpkYXRhID0gZGF0YSAlPiUgZ3JvdXBfYnkoc3ltYm9sKSAlPiUgbXV0YXRlKHQgPSByb3dfbnVtYmVyKCkpCmRhdGEKZGF0YSA9IGFzX3RzaWJibGUoZGF0YSwgaW5kZXggPSB0LCBrZXkgPSBzeW1ib2wpCmBgYAoKIyBNb2RlbCBzcGVjCmBgYHtyfQpmaXQgPSBkYXRhICU+JSBtb2RlbChzdGwgPSBTVEwoYWRqdXN0ZWQpKQpmaXQgfD4KICBjb21wb25lbnRzKCkgfD4KICBhdXRvcGxvdCgpCmZpbHRlcihmaXQsIHN5bWJvbCA9PSAiRElTIikgJT4lIGdnX3RzcmVzaWR1YWxzKCkKYGBgCgpgYGB7cn0KZmlsdGVyKGZpdCwgc3ltYm9sID09ICJESVMiKSAlPiUKICBnZW5lcmF0ZShuZXdfZGF0YSA9IGRhdGEsIHRpbWVzID0gMTAsCiAgICAgICAgICAgYm9vdHN0cmFwX2Jsb2NrX3NpemUgPSA4KSB8PgogIGF1dG9wbG90KC5zaW0pICsKICBhdXRvbGF5ZXIoZmlsdGVyKGRhdGEsIHN5bWJvbD09IkRJUyIpLCBhZGp1c3RlZCwgY29sb3VyID0gImJsYWNrIikgKwogIGd1aWRlcyhjb2xvdXIgPSAibm9uZSIpICsKICBsYWJzKHRpdGxlID0gIlN0b2NrIHByaWNlczogQm9vdHN0cmFwcGVkIHNlcmllcyIsCiAgICAgICB5PSJwcmljZSIpCmBgYAoKYGBge3J9CmZpbHRlcihmaXQsIHN5bWJvbCA9PSAiQU1aTiIpICU+JQogIGdlbmVyYXRlKG5ld19kYXRhID0gZGF0YSwgdGltZXMgPSAxMCwKICAgICAgICAgICBib290c3RyYXBfYmxvY2tfc2l6ZSA9IDEwMCkgfD4KICBhdXRvcGxvdCguc2ltKSArCiAgYXV0b2xheWVyKGZpbHRlcihkYXRhLCBzeW1ib2w9PSJBTVpOIiksIGFkanVzdGVkLCBjb2xvdXIgPSAiYmxhY2siKSArCiAgZ3VpZGVzKGNvbG91ciA9ICJub25lIikgKwogIGxhYnModGl0bGUgPSAiU3RvY2sgcHJpY2VzOiBCb290c3RyYXBwZWQgc2VyaWVzIiwKICAgICAgIHk9InByaWNlIikKYGBgCiMgU2ltdWxhY2nDs24gCgpgYGB7cn0Kc2ltIDwtIGZpdCB8PgogIGdlbmVyYXRlKG5ld19kYXRhID0gZGF0YSwgdGltZXMgPSAxMDAsCiAgICAgICAgICAgYm9vdHN0cmFwX2Jsb2NrX3NpemUgPSA1MCkgJT4lCiAgc2VsZWN0KC0ubW9kZWwsIC1hZGp1c3RlZCkKc2ltCmBgYAoKYGBge3J9CmFyaW1hX2ZvcmVjYXN0cyA8LSBzaW0gfD4KICBtb2RlbChhcmltYSA9IEFSSU1BKC5zaW0pKSB8PgogIGZvcmVjYXN0KGggPSAyMCkKYXJpbWFfZm9yZWNhc3RzIHw+IGZpbHRlcihzeW1ib2w9PSJESVMiKSAlPiUKICBhc190c2liYmxlKGtleSA9IGMoIi5yZXAiLCAic3ltYm9sIiksIGluZGV4ID0gdCkgJT4lCiAgYXV0b3Bsb3QoLm1lYW4pICsKICBhdXRvbGF5ZXIoZmlsdGVyKGRhdGEsIHN5bWJvbD09IkRJUyIpLCBhZGp1c3RlZCwgY29sb3VyID0gImJsYWNrIikgKwogIGd1aWRlcyhjb2xvdXIgPSAibm9uZSIpICsKICBsYWJzKHRpdGxlID0gIlN0b2NrIHByaWNlczogQm9vdHN0cmFwcGVkIHNlcmllcyIseT0icHJpY2UiLCB4ID0gInBlcmlvZCIpCmBgYAoKYGBge3J9CmJhZ2dlZCA8LSBhcmltYV9mb3JlY2FzdHMgfD4gIGdyb3VwX2J5KHN5bWJvbCkgJT4lCiAgc3VtbWFyaXNlKGJhZ2dlZF9tZWFuID0gbWVhbigubWVhbikpCgpkYXRhIHw+IGZpbHRlcihzeW1ib2w9PSJBTVpOIikgJT4lCiAgYXV0b3Bsb3QoKSArCiAgYXV0b2xheWVyKGZpbHRlcihiYWdnZWQsIHN5bWJvbD09IkFNWk4iKSkgKwogIGxhYnModGl0bGUgPSAiU3RvY2sgcHJpY2VzOiBCb290c3RyYXBwZWQgc2VyaWVzIix5PSJwcmljZSIsIHggPSAicGVyaW9kIikKYGBgCgojIEVuc2FtYmxlCgpgYGB7cn0KU1RMRiA8LSBkZWNvbXBvc2l0aW9uX21vZGVsKAogIFNUTChhZGp1c3RlZCB+IHNlYXNvbih3aW5kb3cgPSBJbmYpKSwKICBFVFMoc2Vhc29uX2FkanVzdCB+IHNlYXNvbigiTiIpKQopCgpmaXRfZW5zYW1ibGUgPSBkYXRhICU+JSBtb2RlbCgKICAgICAgICAgICAgICAgICAgICAgICAgICAgIGV0cyA9IEVUUyhhZGp1c3RlZCksCiAgICAgICAgICAgICAgICAgICAgICAgICAgICBhcmltYSA9IEFSSU1BKGFkanVzdGVkKSwKICAgICAgICAgICAgICAgICAgICAgICAgICAgIFNUTEYKKSAlPiUgbXV0YXRlKGNvbWJpbmF0aW9uID0gKGV0cyArIGFyaW1hICsgU1RMRikvMykKCmZjID0gZml0X2Vuc2FtYmxlICU+JSBmb3JlY2FzdChoID0gMjApCmBgYAoKYGBge3J9CmZpdF9lbnNhbWJsZQpgYGAKYGBge3J9CmFjY3VyYWN5KGZpdF9lbnNhbWJsZSkgJT4lIGFycmFuZ2UoTUFQRSkKYGBgCgoKYGBge3J9CmZjICU+JSBhdXRvcGxvdChkYXRhLCBsZXZlbD1OVUxMKQpgYGAKCmBgYHtyfQp0aWNrZXIgPSAiRElTIgpmaXRfZW5zYW1ibGUgJT4lIGZpbHRlcihzeW1ib2wgPT0gdGlja2VyKSAlPiUgYXVnbWVudCgpIHw+CiAgZ2dwbG90KGFlcyh4ID0gdCkpICsKICBnZW9tX2xpbmUoYWVzKHkgPSBhZGp1c3RlZCwgY29sb3VyID0gInJlYWxlcyIpKSArCiAgZ2VvbV9saW5lKGFlcyh5ID0gLmZpdHRlZCwgY29sb3VyID0gLm1vZGVsKSkgKwogIGxhYnMoeSA9IE5VTEwsCiAgICB0aXRsZSA9IHRpY2tlcgogICkgKwogIGd1aWRlcyhjb2xvdXIgPSBndWlkZV9sZWdlbmQodGl0bGUgPSBOVUxMKSkKYGBgCgoKCg==